home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / contsens / errorenv.c < prev    next >
C/C++ Source or Header  |  1991-02-08  |  22KB  |  941 lines

  1.  
  2. /*   Copyright (C) 1990 Riet Oolman
  3.  
  4. This file is part of GLASS.
  5.  
  6. GLASS is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GLASS is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GLASS; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* file:  errorenv.c
  21.    author: H. Oolman
  22.    last modified: 8-2-1991
  23.    purpose: error registration,
  24.             error printing,
  25.             updating of type environment
  26.             general functions on lists */
  27.  
  28.  
  29. #include "handleds.h"
  30. #include "check.ds.h"
  31. #include "check.var.h"
  32. #include "check.afuncs.h"
  33. #include "errorenv.h"
  34.  
  35. Void error(ernm, tyfst, tysnd, name, erval, iswarn)
  36. long ernm;
  37. typcrec *tyfst, *tysnd;
  38. symbol name;
  39. val erval;
  40. boolean iswarn;
  41. {
  42.   /* error messages (warning if iswarn), in which a name may occur are stored.
  43.      erval: expression with the error in its type
  44.      They may become
  45.      invalid yet, so are not yet printed. It is assumed that 'UNKNOWN' types
  46.      for parts of expressions are not filled in !! (since these would have to be
  47.      changed back too) */
  48.   errorrec *e;
  49.  
  50.   /* error */
  51.   if (iswarn && !takewarning)
  52.     return;
  53.   e = (errorrec *)malloc(sizeof(errorrec));
  54.   e->erno = ernm;
  55.   if (name != NULL) e->sym = Copysymbol(name);
  56.   else e->sym = NULL;
  57.   /* a copy, because unique extensions not wanted here */
  58.   e->tyf = tyfst;
  59.   e->tys = tysnd;
  60.   e->errval = erval;
  61.   e->nesting = nestednames;
  62.   e->orig = nestednorig;
  63.   e->next = errorlist;
  64.   errorlist = e;
  65. }
  66.  
  67.  
  68. /* for printing errormessages: */
  69.  
  70. #define max             99
  71.  
  72.  
  73. typedef long intl[max + 1];
  74.  
  75.  
  76. Void myprint_orig(f, org)
  77. FILE *f;
  78. orig org;
  79. { putc( '(', f );
  80.   fprint_string( f, org->file );
  81.   putc( ',', f );
  82.   fprint_inum( f, org->line );
  83.   putc( ')', f ); /* no newline at end, like myprint_orig has */
  84. }
  85.  
  86. boolean EmporSomUnk(ty)
  87. typcrec *ty;
  88. /* true <-> ty is EMPTYT or SOME (UNKNOWN t)
  89.    when you forget the INDIRs 
  90.    Used because in case of !takewarning, EMPTYT and SOME (UNKNOWN t)
  91.    are treated the same 
  92.    Beautifies printing CT t_0 (CT t_1 (SOME (UNKNOWN t))):
  93.    gives t_0 & t_1, instead of t_0 $ t_1 $ t* 
  94.    Small disadvantage: t* -> t* (with t a type variable) is printed as <> -> <> 
  95. */
  96. { typcrec *ty1;
  97.  
  98.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  99.   if (ty->kind == kindEMPTYT) return true;
  100.   else
  101.   { if (ty->kind == kindSOME)
  102.     { ty1 = ty->SOME.tcpart;
  103.       while (ty1->kind == kindINDIR) ty1 = ty1->INDIR.tcind;
  104.       return (ty1->kind == kindUNKNOWN);
  105.     }
  106.     else return false;
  107.   };
  108. }
  109.  
  110. Local Void Writetypcptr1 PP((FILE *f, typcrec *ty));
  111.  
  112. /* Local variables for Writeloctypes: */
  113. struct LOC_Writeloctypes {
  114.   intl unknrs;
  115.   nminstrec *locs;
  116.   long lastu;
  117. } ;
  118.  
  119. Local Void wlt(f,ty, LINK)
  120. FILE *f;
  121. typcrec *ty;
  122. struct LOC_Writeloctypes *LINK;
  123. { long i;
  124.   nminstrec *l;
  125.   boolean found;
  126.   long FORLIM;
  127.  
  128.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  129.   switch (ty->kind) {
  130.  
  131.   case kindUNKNOWN:
  132.     i = 0;
  133.     found = false;
  134.     FORLIM = LINK->lastu;
  135.     for (i = 0; i <= FORLIM; i++)
  136.       found = (found || LINK->unknrs[i] == ty->UNKNOWN.unknm);
  137.     if (!found) {
  138.       if (LINK->lastu == 0 && LINK->locs == NULL)
  139.     putc('{',f);
  140.       else
  141.     fprintf(f,", ");
  142.       fprintf(f,"Unkn");
  143.       fprintf(f,"%ld", ty->UNKNOWN.unknm);
  144.       if (LINK->lastu < max) {
  145.     LINK->lastu++;
  146.     LINK->unknrs[LINK->lastu] = ty->UNKNOWN.unknm;
  147.       }
  148.     }
  149.     break;
  150.  
  151.   case kindLOC:
  152.     l = LINK->locs;
  153.     found = false;
  154.     while (l != NULL) {
  155.       found |= (Equalsymbol(l->nm, ty->LOC.locname) &&
  156.         l->inst == ty->LOC.inst);
  157.       l = l->next;
  158.     }
  159.     if (!found) {
  160.       if (LINK->lastu == 0 && LINK->locs == NULL)
  161.     putc('{',f);
  162.       else
  163.     fprintf(f,", ");
  164.       Writesymbol(f, ty->LOC.locname);
  165.       if (takewarning) fprintf(f, "/* inst. %ld */",ty->LOC.inst);
  166.       l = (nminstrec *)malloc(sizeof(nminstrec));
  167.       l->nm = ty->LOC.locname;
  168.       l->inst = ty->LOC.inst;
  169.       l->next = LINK->locs;
  170.       LINK->locs = l;
  171.     }
  172.     break;
  173.  
  174.   case kindSINGLEARROW:
  175.     wlt(f,ty->SINGLEARROW.tcarg, LINK);
  176.     wlt(f,ty->SINGLEARROW.tcres, LINK);
  177.     break;
  178.  
  179.   case kindINT:
  180.   case kindFLOAT:
  181.   case kindBOOL:
  182.   case kindSTRING:
  183.   case kindEMPTYT:
  184.   case kindBASETY:
  185.   case kindAPS:   /* nothing */
  186.     break;
  187.  
  188.   case kindSYSTY:
  189.     wlt(f,ty->SYSTY.syscomp, LINK);
  190.     break;
  191.  
  192.   case kindCT:
  193.     wlt(f,ty->CT.tcfirst, LINK);
  194.     wlt(f,ty->CT.tcrest, LINK);
  195.     break;
  196.  
  197.   case kindSOME:
  198.     if (takewarning || !(EmporSomUnk(ty)))
  199.     {wlt(f,ty->SOME.tcpart, LINK);}
  200.     break;
  201.  
  202.   case kindALL:
  203.     break;
  204.   }
  205. }  /* wlt */
  206.  
  207. Local Void Writeloctypes(f,ty)
  208. FILE *f;
  209. typcrec *ty;
  210. {
  211.   /* write the set of all UNKNOWNs */
  212.   struct LOC_Writeloctypes V;
  213.  
  214.   V.lastu = 0;
  215.   V.locs = NULL;
  216.   wlt(f,ty, &V);
  217.   if (V.lastu > 0 || V.locs != NULL) fprintf(f,"} ");
  218. }  /* Writeloctypes */
  219.  
  220. #undef max
  221.  
  222. Local Void Writesystemtype PP((FILE *f, dirgraphrec *dg, typcrec *ty));
  223.  
  224. Local Void Writedirgraphptr(f, dg)
  225. FILE *f;
  226. dirgraphrec *dg;
  227. {
  228.   /* prints the sidections in a system type */
  229.   switch (dg->kind) {
  230.  
  231.   case kindCd:
  232.     putc('(', f);
  233.     Writedirgraphptr(f, dg->Cd.dgfirst);
  234.     fprintf(f, ") (");
  235.     Writedirgraphptr(f, dg->Cd.dgrest);
  236.     putc(')', f);
  237.     break;
  238.  
  239.   case kindSd:
  240.     putc('(', f);
  241.     Writedirgraphptr(f, dg->Sd.dgpart);
  242.     fprintf(f, ")* (");
  243.     Writedirgraphptr(f, dg->Sd.dglast);
  244.     putc(')', f);
  245.     break;
  246.  
  247.   case kindOd:
  248.     switch (dg->Od.basedir->kind) {
  249.  
  250.     case kindINTO:
  251.       putc('?', f);
  252.       break;
  253.  
  254.     case kindOUT:
  255.       putc('!', f);
  256.       break;
  257.  
  258.     case kindNON:
  259.       fprintf(f, "none");
  260.       break;
  261.     }
  262.     break;
  263.   }
  264. }  /* Writedirgraphptr */
  265.  
  266. Local Void WritesystyCT(f, dg, ty, first)
  267. FILE *f;
  268. dirgraphrec *dg;
  269. typcrec *ty;
  270. boolean first;
  271. {
  272.   /* tries to write out a type with directions and CT or SOME in it, so one that should
  273.      end in empty 
  274.      When first is true, ty->kind is SOME or CT */
  275.   dirgraphrec *sd, *fd;
  276.  
  277.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  278.   switch (ty->kind) {
  279.  
  280.   case kindCT:
  281.     if (!first)
  282.       fprintf(f, " & ");
  283.     putc('(', f);
  284.     if (dg->kind == kindCd) {
  285.       fd = dg->Cd.dgfirst;
  286.       sd = dg->Cd.dgrest;
  287.     } else {
  288.       if (dg->kind == kindSd) {
  289.     fd = dg->Sd.dgpart;
  290.     sd = dg;
  291.       } else {
  292.     if (dg->kind == kindOd) {
  293.       fd = dg;
  294.       sd = dg;
  295.     }
  296.       }
  297.     }
  298.     Writesystemtype(f, fd, ty->CT.tcfirst);
  299.     putc( ')',f);
  300.     if (first && !takewarning && EmporSomUnk(ty->CT.tcrest))
  301.     fprintf(f,"^1"); /* 't CT <>' can not be printed with &'s */
  302.     else
  303.     WritesystyCT(f, sd, ty->CT.tcrest, false);
  304.     break;
  305.  
  306.   case kindEMPTYT:
  307.     break;
  308.  
  309.   case kindSOME:
  310.     if (dg->kind == kindCd) 
  311.     WritesystyCT(f,dg,BuildCT(ty->SOME.tcpart,ty),first);
  312.     else {  /* dir. at end neglected */
  313.       if (dg->kind == kindOd) fd = dg;
  314.       else fd = dg->Sd.dgpart;
  315.       if (first) {
  316.       if (!takewarning && EmporSomUnk(ty)) 
  317.       fprintf(f,"<>");
  318.       else {
  319.     putc('(', f);
  320.     Writesystemtype(f, fd, ty->SOME.tcpart);
  321.     fprintf(f, ")*");
  322.     }
  323.       } else {
  324.       if (takewarning || !(EmporSomUnk(ty)))
  325.       { fprintf(f,"& (");
  326.     Writesystemtype(f, fd, ty->SOME.tcpart);
  327.     fprintf(f,") ... & (");
  328.     Writesystemtype(f, fd, ty->SOME.tcpart);
  329.     putc(')',f);
  330.       }
  331.       }
  332.     }
  333.     break;
  334.  
  335.   case kindUNKNOWN:
  336.     if (takewarning) fprintf(f, "..something unknown..");
  337.     break;
  338.  
  339.   case kindSINGLEARROW:
  340.   case kindINT:
  341.   case kindFLOAT:
  342.   case kindBOOL:
  343.   case kindSTRING:
  344.   case kindSYSTY:
  345.   case kindLOC:
  346.   case kindBASETY:
  347.   case kindALL:
  348.   case kindAPS:
  349.     fprintf(f, "& ??");
  350.     break;
  351.   }
  352. }  /* WritesystyCT */
  353.  
  354. Local Void Writesystemtype(f, dg, ty)
  355. FILE *f;
  356. dirgraphrec *dg;
  357. typcrec *ty;
  358. {
  359.   /* tries to write the directions dg of a systemtype in between the
  360.      bundletype ty */
  361.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  362.   switch (dg->kind) {
  363.  
  364.   case kindCd:
  365.     if (ty->kind == kindCT || ty->kind == kindSOME)
  366.       WritesystyCT(f, dg, ty, true);
  367.     else {  /* should not occur... */
  368.       fprintf(f, "with directions ");
  369.       Writedirgraphptr(f, dg);
  370.       fprintf(f, " in ");
  371.       Writetypcptr1(f, ty);
  372.     }
  373.     break;
  374.  
  375.   case kindOd:
  376.     switch (dg->Od.basedir->kind) {
  377.  
  378.     case kindINTO:
  379.       fprintf(f, "?(");
  380.       break;
  381.  
  382.     case kindOUT:
  383.       fprintf(f, "!(");
  384.       break;
  385.  
  386.     case kindNON:   /* nothing, like in GLASS */
  387.       break;
  388.     }
  389.     Writetypcptr1(f, ty);
  390.     if (dg->Od.basedir->kind != kindNON)
  391.       putc(')', f);
  392.     break;
  393.  
  394.   case kindSd:
  395.     if (ty->kind == kindCT || ty->kind == kindSOME)
  396.       WritesystyCT(f, dg, ty, true);
  397.     else {  /* should not occur... */
  398.       fprintf(f, "with directions ");
  399.       Writedirgraphptr(f, dg);
  400.       fprintf(f, " in ");
  401.       Writetypcptr1(f, ty);
  402.     }
  403.     break;
  404.   }
  405. }  /* Writesystemtype */
  406.  
  407. Local Void Writetypcptr1(f, ty)
  408. FILE *f;
  409. typcrec *ty;
  410. {
  411.  
  412.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  413.   switch (ty->kind) {
  414.  
  415.   case kindSINGLEARROW:
  416.     putc('(', f);
  417.     Writetypcptr1(f, ty->SINGLEARROW.tcarg);
  418.     fprintf(f, ") -> ");
  419.     Writetypcptr1(f, ty->SINGLEARROW.tcres);
  420.     break;
  421.  
  422.   case kindINT:
  423.     fprintf(f, "INT");
  424.     break;
  425.  
  426.   case kindFLOAT:
  427.     fprintf(f, "FLOAT");
  428.     break;
  429.  
  430.   case kindSTRING:
  431.     fprintf(f, "STRING");
  432.     break;
  433.  
  434.   case kindBOOL:
  435.     fprintf(f, "BOOL");
  436.     break;
  437.  
  438.   case kindSYSTY:
  439.     putc('[', f);
  440.     Writesystemtype(f, ty->SYSTY.sysdirs, ty->SYSTY.syscomp);
  441.     putc(']', f);
  442.     break;
  443.  
  444.   case kindEMPTYT:
  445.     fprintf(f, "<>");
  446.     break;
  447.  
  448.   case kindCT:
  449.     WritesystyCT(f,BuildOd(BuildNON()),ty,true);
  450.     /* print this as if interwoven with (empty) directions */
  451.     break;
  452.  
  453.   case kindAPS:
  454.     fprintf(f, "APPSET");
  455.     break;
  456.  
  457.   case kindUNKNOWN:
  458.     fprintf(f, "Unkn");
  459.     fprintf(f, "%ld", ty->UNKNOWN.unknm);
  460.     break;
  461.  
  462.   case kindSOME:
  463.     WritesystyCT(f,BuildOd(BuildNON()),ty,true);
  464.     /* print this as if interwoven with (empty) directions */
  465.     break;
  466.  
  467.   case kindLOC:
  468.     Writesymbol(f, ty->LOC.locname);
  469.     if (takewarning) fprintf(f, "/* inst. %ld */",ty->LOC.inst);
  470.     break;
  471.  
  472.   case kindBASETY:
  473.     Writesymbol(f, ty->BASETY.btname);
  474.     if (takewarning && ty->BASETY.bor != NULL) {
  475.       fprintf(f, "/*");
  476.       myprint_orig(f, ty->BASETY.bor);
  477.       fprintf(f, "*/");
  478.     }
  479.     break;
  480.  
  481.   case kindALL:
  482.     break;
  483.   }
  484. }  /* Writetypcptr1 */
  485.  
  486. Local Void Writetypcptr(f, ty)
  487. FILE *f;
  488. typcrec *ty;
  489. {
  490.   /* tries to print a type as understandable as possible */
  491.   Writeloctypes(f,ty);
  492.   Writetypcptr1(f, ty);
  493. }  /* Writetypcptr */
  494.  
  495. Local boolean equalnested(nms1, nms2)
  496. symbol nms1, nms2;
  497. {
  498.   /* tests if nms1 and nms2 are the same list of names */
  499.   boolean Result;
  500.  
  501.   Result = (nms1 == NULL && nms2 == NULL);
  502.   if (nms1 != NULL && nms2 != NULL)
  503.     return (Equalsymbol(nms1, nms2) & equalnested(nms1->next, nms2->next));
  504.   return Result;
  505. }  /* equalnested */
  506.  
  507. Local Void writenestednames(f,nms)
  508. FILE *f;
  509. symbol nms;
  510. { /* write out the names in the list nms in reverse order, separated by / */
  511.   if (nms == NULL) return;
  512.   writenestednames(f,nms->next);
  513.   if (nms->next != NULL) putc('/',f);
  514.   Writesymbol(f, nms);
  515. }  /* writenestednames */
  516.  
  517.  
  518. Void printerrors(unparsval, errorlist)
  519. _PROCEDURE unparsval;
  520. errorrec *errorlist;
  521. {
  522.   /* prints error messages concerning type errors
  523.      unparsval: unparses valptr's; differs for full and kernel check
  524.      errorlist: errors to be printed */
  525.  
  526.   if (errorlist == NULL) return;
  527.   printerrors(unparsval, errorlist->next);   /* stored in reverse */
  528.   errordiscovered = true;
  529.   if (errorlist->next != NULL) {
  530.     if (!equalnested(errorlist->nesting, errorlist->next->nesting)) {
  531.       if (errorlist->nesting != NULL){
  532.     fprintf(stderr,"in ");
  533.       writenestednames(stderr,errorlist->nesting);
  534.       if (errorlist->orig != NULL && takewarning) {
  535.     putc(' ',stderr);
  536.     myprint_orig(stderr, errorlist->orig);
  537.       }
  538.     fprintf(stderr,":\n"); }
  539.     }
  540.   } else {
  541.     if (errorlist->nesting != NULL) {
  542.     fprintf(stderr,"in ");
  543.     writenestednames(stderr,errorlist->nesting);
  544.     if (errorlist->orig != NULL && takewarning) {
  545.       putc(' ',stderr);
  546.       myprint_orig(stderr, errorlist->orig);
  547.     }
  548.       fprintf(stderr,":\n");}
  549.   }
  550.   fprintf(stderr,"  ");
  551.   switch (errorlist->erno) {
  552.  
  553.   case 0:
  554.     fprintf(stderr,"typenaming \"");
  555.     Writesymbol(stderr, errorlist->sym);
  556.     fprintf(stderr,"\" cyclicly defined\n");
  557.     break;
  558.  
  559.   case 1:
  560.     fprintf(stderr,"undefined name \"");
  561.     Writesymbol(stderr, errorlist->sym);
  562.     fprintf(stderr,"\" in type declaration\n");
  563.     break;
  564.  
  565.   case 2:
  566.     fprintf(stderr,
  567.       "(W) description can be interpreted both directionally and adirectionally\n");
  568.     break;
  569.  
  570.   /* !! (W) must coincide with true as last parameter of 'error' */
  571.   case 3:
  572.     fprintf(stderr,"(W) both uni- and adirectional interpretation give errors\n");
  573.     break;
  574.  
  575.   case 4:
  576.     fprintf(stderr,"no parametertype for parameter\n");
  577.     break;
  578.  
  579.   case 5:
  580.     fprintf(stderr,"wrong type `");
  581.     Writetypcptr(stderr, errorlist->tyf);
  582.     fprintf(stderr,"' for `");
  583.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  584.     stderr, errorlist->errval);
  585.     fprintf(stderr,"'\n");
  586.     break;
  587.  
  588.   case 6:
  589.     putc('`',stderr);
  590.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  591.     stderr, errorlist->errval);
  592.     fprintf(stderr,"' can not be typed with `");
  593.     Writetypcptr(stderr, errorlist->tyf);
  594.     if (errorlist->tys!=NULL) 
  595.     { fprintf(stderr,"' and `");
  596.       Writetypcptr(stderr, errorlist->tys);}
  597.     fprintf(stderr,"' for subpart(s)\n");
  598.     break;
  599.  
  600.   case 7:
  601.     fprintf(stderr,"!!contsens: length of name surpassed: truncated!!\n");
  602.     break;
  603.  
  604.   case 8:
  605.     fprintf(stderr,"syntactically incorrect system type (after writing out)\n");
  606.     break;
  607.  
  608.   case 9:
  609.     Writesymbol(stderr, errorlist->sym);
  610.     fprintf(stderr," defined more than once\n");
  611.     break;
  612.  
  613.   case 10:
  614.     fprintf(stderr,"bug in program (");
  615.     Writesymbol(stderr, errorlist->sym);
  616.     fprintf(stderr,"); alarm author\n");
  617.     break;
  618.  
  619.   case 11:
  620.     fprintf(stderr,"type `");
  621.     Writetypcptr(stderr, errorlist->tyf);
  622.     fprintf(stderr,"' occurs as part of itself\n");
  623.     break;
  624.  
  625.   case 12:
  626.     fprintf(stderr,"incompatible types `");
  627.     Writetypcptr(stderr, errorlist->tyf);
  628.     fprintf(stderr,"' and `");
  629.     Writetypcptr(stderr, errorlist->tys);
  630.     fprintf(stderr,"' in `");
  631.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  632.     stderr, errorlist->errval);
  633.     fprintf(stderr,"'\n");
  634.     break;
  635.  
  636.   case 13:
  637.     fprintf(stderr,"conflicting directions in type of ");
  638.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  639.     stderr, errorlist->errval);
  640.     putc('\n',stderr);
  641.     break;
  642.  
  643.   case 14:
  644.     fprintf(stderr,"wrong directions in type of ");
  645.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  646.     stderr, errorlist->errval);
  647.     putc('\n',stderr);
  648.     break;
  649.  
  650.   case 15:
  651.     fprintf(stderr,"tuple/list type wanted for `");
  652.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  653.     stderr, errorlist->errval);
  654.     fprintf(stderr,"'; `");
  655.     Writetypcptr(stderr, errorlist->tyf);
  656.     fprintf(stderr,"' found\n");
  657.     break;
  658.  
  659.   case 16:
  660.     putc('`',stderr);
  661.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  662.     stderr, errorlist->errval);
  663.     fprintf(stderr,"' (type: `");
  664.     Writetypcptr(stderr, errorlist->tyf);
  665.     fprintf(stderr,"') should have been a connection\n");
  666.     break;
  667.  
  668.   case 17:
  669.     fprintf(stderr,"list type expected in `");
  670.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  671.     stderr, errorlist->errval);
  672.     fprintf(stderr,"'\n");
  673.     break;
  674.  
  675.   case 18:
  676.     fprintf(stderr,"type (after writing out) is not according to the syntax\n");
  677.     break;
  678.  
  679.   case 19:
  680.     fprintf(stderr,"only names allowed as formal parameter of def.\n");
  681.     break;
  682.  
  683.   case 20:
  684.     fprintf(stderr,"expression in power type too complicated\n");
  685.     break;
  686.  
  687.   case 21:
  688.     fprintf(stderr,"(W) undefined name \"");
  689.     Writesymbol(stderr, errorlist->sym);
  690.     fprintf(stderr,"\" used in power type\n");
  691.     break;
  692.  
  693.   case 22:
  694.     fprintf(stderr,"(W) have you maybe forgotten to declare \"");
  695.     Writesymbol(stderr, errorlist->sym);
  696.     fprintf(stderr,"\"?\n");
  697.     break;
  698.  
  699.   case 23:
  700.     fprintf(stderr,"system type expected\n");
  701.     break;
  702.  
  703.   case 24:
  704.     fprintf(stderr,"index in `");
  705.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  706.     stderr, errorlist->errval);
  707.     fprintf(stderr,"' too large\n");
  708.     break;
  709.  
  710.   case 25:
  711.     fprintf(stderr,"index in `");
  712.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  713.     stderr, errorlist->errval);
  714.     fprintf(stderr,"' too small\n");
  715.     break;
  716.  
  717.   case 26:
  718.     fprintf(stderr,"undefined atomname ");
  719.     Writesymbol(stderr, errorlist->sym);
  720.     putc('\n',stderr);
  721.     break;
  722.  
  723.   case 27:
  724.     putc('`',stderr);
  725.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  726.     stderr, errorlist->errval);
  727.     fprintf(stderr,"' cannot be turned into kernel Glass\n");
  728.     break;
  729.  
  730.   case 28:
  731.     fprintf(stderr,"(W) I put {...} around`");
  732.     (*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
  733.     stderr, errorlist->errval);
  734.    fprintf(stderr,"' because only adir. interpretation can be correct\n");
  735.    break;
  736.  
  737.   default:
  738.     fprintf(stderr,"error number (%ld) too large\n", errorlist->erno);
  739.     break;
  740.   }
  741. }  /* printerrors */
  742.  
  743.  
  744. Void addext(nm, ext)
  745. symbol nm;
  746. long ext;
  747. { /* replace name nm with extended name nm_ext */
  748.   long lb, lg, i, rest, lth;
  749.  
  750.   lb = 1;
  751.   lg = 0;
  752.   while (lb * 10 <= ext) {
  753.     lb *= 10;
  754.     lg++;
  755.   }
  756.   rest = ext;
  757.   lth = nm->length;
  758.   for (i = 0; i <= lg + 1; i++) {
  759.     if (lth < wordlength) {
  760.       lth++;
  761.       if (i == 0)
  762.     nm->body[lth - 1] = '_';
  763.       else {
  764.     nm->body[lth - 1] = (Char)(rest / lb + '0');
  765.     rest %= lb;
  766.     lb /= 10;
  767.       }
  768.     } else
  769.       error(7L, NULL, NULL, NULL, NULL, false);
  770.   }
  771.   nm->length = lth;
  772. }
  773.  
  774.  
  775. /* for environment: */
  776.  
  777. Void mark_(curenv)
  778. envrec **curenv;
  779. {
  780.   /* mark point where piece of curenv added in front may be chopped off,
  781.      by element with empty name (assumption: no normal name has length 0) */
  782.   envrec *r;
  783.  
  784.   r = (envrec *)malloc(sizeof(envrec));
  785.       /* added in front, to make removing added elements easy */
  786.   r->next = *curenv;
  787.   r->name0 = marker;
  788.   *curenv = r; 
  789. }  /* mark */
  790.  
  791.  
  792. Local boolean partunknown(t)
  793. typcrec *t;
  794. {
  795.   boolean Result;
  796.  
  797.   while (t->kind == kindINDIR) t = t->INDIR.tcind;
  798.   switch (t->kind) {
  799.  
  800.   case kindUNKNOWN:
  801.     Result = t->UNKNOWN.mustconn;
  802.     break;
  803.  
  804.   case kindCT:
  805.     Result = partunknown(t->CT.tcfirst) | partunknown(t->CT.tcrest);
  806.     break;
  807.  
  808.   case kindSOME:
  809.     Result = partunknown(t->SOME.tcpart);
  810.     break;
  811.  
  812.   case kindSINGLEARROW:
  813.   case kindINT:
  814.   case kindFLOAT:
  815.   case kindBOOL:
  816.   case kindSTRING:
  817.   case kindSYSTY:
  818.   case kindEMPTYT:
  819.   case kindLOC:
  820.   case kindALL:
  821.   case kindAPS:
  822.   case kindBASETY:
  823.     Result = false;
  824.     break;
  825.   }
  826.   return Result;
  827. }  /* partunknown */
  828.  
  829.  
  830. Void release_(curenv, uniq)
  831. envrec **curenv;
  832. boolean uniq;
  833. {
  834.   /* remove leading part of curenv upto and including first marker. Check
  835.      for unknown names first though, and if 'uniq' replace the name with its
  836.      uniquely extended version */
  837.   envrec *cur;
  838.   symbol WITH;
  839.  
  840.   /* release */
  841.   if (forfull) 
  842.   { cur = *curenv;
  843.     if (takewarning) 
  844.     { while (!ismark(cur)) 
  845.       { if (partunknown(cur->typc0))
  846.       error(22L, NULL, NULL, cur->name0, NULL, true);
  847.     cur = cur->next;
  848.       }
  849.     }
  850.     while (!ismark(*curenv)) {
  851.       if (uniq) 
  852.       { WITH = (*curenv)->name0;
  853.     if (WITH->body[0] == specch) 
  854.     { WITH->body[0] = 'e';
  855.       WITH->length = 3;}
  856.     addext(WITH, (*curenv)->uniqext);
  857.       }
  858.       *curenv = (*curenv)->next;
  859.     }
  860.   } else 
  861.   { while (!ismark(*curenv)) *curenv = (*curenv)->next; }
  862.   *curenv = (*curenv)->next;   /* marker removed too */
  863. }
  864.  
  865. Void update(curenv, n, t)
  866. envrec **curenv;
  867. symbol n;
  868. typcrec *t;
  869. {
  870.   /* add name n with type t in curenv;
  871.      generate unique string (number) as extension;
  872.   */
  873.   envrec *r;
  874.  
  875.   r = (envrec *)malloc(sizeof(envrec));
  876.       /* added in front, to make removing added elements easy */
  877.   r->next = *curenv;
  878.   r->name0 = n;
  879.   r->typc0 = t;
  880.   r->uniqext = extsupply;
  881.   if (forfull)
  882.     extsupply++;
  883.   *curenv = r;
  884. }  /* update */
  885.  
  886.  
  887. typcrec *lookup(curenv, s)
  888. envrec *curenv;
  889. symbol *s;
  890. { /* deliver type associated with name s in curenv.
  891.      s afterwards points at name in curenv, if found.
  892.      s not present <=> lookup=nil */
  893.   envrec *env;
  894.  
  895.   env = curenv;
  896.   while (true) {
  897.     if (env == NULL) return NULL;
  898.     if (Equalsymbol(env->name0, *s)) {
  899.       *s = env->name0;   /* make it point at the same */
  900.       return  env->typc0;
  901.     } else
  902.       env = env->next;
  903.   }
  904. }
  905.  
  906. /* operations on lists of names: */
  907.  
  908. boolean isin(s, slist)
  909. symbol s, slist;
  910. { /* is s in list slist? */
  911.  
  912.   while (true) {
  913.     if (slist == NULL) return false; 
  914.     else if (Equalsymbol(s, slist)) return true; 
  915.          else slist = slist->next;
  916.   }
  917. }
  918.  
  919.  
  920. Void addcopy(s, slist)
  921. symbol s, *slist;
  922. {
  923.   /* add s to the list slist */
  924.   symbol copy;
  925.  
  926.   copy = Copysymbol(s);   /* to keep original ds intact */
  927.   copy->next = *slist;
  928.   *slist = copy;
  929. }  /* addcopy */
  930.  
  931.  
  932. Void addunequal(s, slist)
  933. symbol s, *slist;
  934. {
  935.   /* s  is not allowed already to occur in slist, otherwise added */
  936.   if (isin(s, *slist))
  937.     error(9L, NULL, NULL, s, NULL, false);
  938.   else
  939.     addcopy(s, slist);
  940. }  /* addunequal */
  941.